home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Yerk 3.6.6 / Float source / Float < prev    next >
Encoding:
Text File  |  1992-06-24  |  5.7 KB  |  183 lines  |  [TEXT/YERK]
  1. t mstack
  2.         move.l  (a2),a0     ; base address
  3.         adda.l   a3,a0
  4.         lea     2(a3,d1.l),a1 
  5.         move.l  (a0)+,(a1)+ ; copy float data
  6.         move.l  (a0)+,(a1)+       
  7.         move.w  (a0)+,(a1)+   
  8.         move.l  d1,-(a7)    ; return new float
  9. ;CODE    
  10.  
  11. :CODE  putFlt  
  12.         move.l  (a7),d0
  13.         move.l  YERK[(fltDisp)],d7
  14.         jsr     0(a3,d7.l)     ; get rid of float in D0
  15.         move.l  d5,a2       ; get mstack
  16.         move.l  (a2),a1     ; base address
  17.         adda.l   a3,a1
  18.         move.l  (a7)+,d0
  19.         lea     2(a3,d0.l),a0
  20.         move.l  (a0)+,(a1)+ ; copy float data
  21.         move.l  (a0)+,(a1)+       
  22.         move.w  (a0)+,(a1)+   
  23. ;CODE   
  24.  
  25. \ set up stack for float object arithmetics so that the 
  26. \ result is stored in the receiver.  ( parm -- rcvr parm )
  27. :CODE  fltOp
  28.         move.l  d5,a2       ; get mstack
  29.         move.l  (a7),d0
  30.         move.l  (a2),(a7)   ; base address
  31.         subq.l  #2,(a7)     ; floats have status word
  32.         move.l  d0,-(a7)
  33. ;CODE         
  34.              
  35. :CLASS  Float   <Super Object
  36.         10 Bytes data
  37.  
  38. \ ( -- x ) push private data onto stack
  39. :M  GET:   getFlt  ;M
  40.  
  41. \ ( x -- ) store float into private data
  42. :M  PUT:   putFlt  ;M
  43.  
  44. \ ( Float -- ) assign this float's data to another object
  45. :M  =:     getFlt swap put: Float ;M
  46.  
  47. \ ----- Arithmetic operations take a stack float (not a float obj)
  48. \ ( x -- ) add a float to the contents of this object 
  49. :M  +:      fltOp f+ drop  ;M
  50.  
  51. \ ( x -- ) 
  52. :M  -:      fltOp f- drop ;M
  53.  
  54. \ ( x -- )  
  55. :M  *:      fltOp f*  drop  ;M
  56.  
  57. \ ( x -- )   
  58. :M  /:      fltOp f/  drop ;M
  59.  
  60. \ ( -- sin )     return sine of object  
  61. :M  SIN:      getFlt sin   ;M
  62.  
  63. \ ( -- cos )     return cosine of object  
  64. :M  COS:      getFlt cos   ;M
  65.  
  66. \ ( -- tan )     return tangent of object  
  67. :M  TAN:      getFlt tan   ;M
  68.  
  69. \ ( -- arcTan)     return arctangent of object  
  70. :M  ARCTAN:    getFlt arcTan    ;M
  71.  
  72. \ ( -- ln)     return natural log of object  
  73. :M  LN:       getFlt ln      ;M
  74.  
  75. \ ( -- exp )     return exp of object  
  76. :M  EXP:      getFlt exp   ;M
  77.  
  78. \ ( -- log)     return log base 10 of object  
  79. :M  LOG:      getFlt log   ;M
  80.  
  81. \ ( -- alog)     return antilog of object  
  82. :M  ANTILOG:  getFlt antilog   ;M
  83.  
  84. \ ( -- )     convert radians to degrees and return result
  85. :M  DEG:      getFlt rad2deg    ;M
  86.  
  87. \ ( -- )     convert from radians to degrees and return result
  88. :M  RAD:      getFlt deg2rad    ;M
  89.  
  90. \ ( -- )     compute absolute value and return result
  91. :M  ABSVAL:   getFlt fabs    ;M
  92.  
  93. \ ( -- )     change sign and return result
  94. :M  NEG:      getFlt fnegate     ;M
  95.  
  96. \ ( -- )   negate this object's data
  97. :M  NEGATE:   copym 2- fnegate  drop ;M
  98.  
  99. \ ( -- )     
  100. :M  PRINT:      getFlt e.      ;M
  101.  
  102. ;CLASS
  103.  
  104. \ optimized access primitives for float array
  105. :CODE  fltAt
  106.         move.l  YERK[(fltNew)],d7
  107.         jsr     0(a3,d7.l)      ; get new float in d1
  108.         move.l  d5,a2           ; get mstack
  109.         move.l  (a2),a0         ; object base
  110.         adda.l   a3,a0
  111.         move.l    -4(a0),d7        ; get class
  112.         adda.w    $12(a3,d7.l),a0    ; offset for ivar
  113.         move.l  (a7),d0         ; get idx
  114.         mulu    #10,d0          ; convert to offset
  115.         lea     4(a0,d0.l),a0   ; pt to element
  116.         lea     2(a3,d1.l),a1   ; pt to target
  117.         move.l  (a0)+,(a1)+     ; deep copy of float data
  118.         move.l  (a0)+,(a1)+
  119.         move.w  (a0)+,(a1)+
  120.         move.l  d1,(a7)         ; push float ptr
  121. ;CODE
  122.  
  123. :CODE  fltTo
  124.         move.l  4(a7),d0        ; get the source float
  125.         move.l  YERK[(fltDisp)],d7
  126.         jsr     0(a3,d7.l)      ; dispose of source float in d0
  127.         move.l  d5,a2           ; get mstack
  128.         move.l  (a2),a0         ; object base
  129.         adda.l   a3,a0
  130.         move.l    -4(a0),d7        ; get class
  131.         adda.w    $12(a3,d7.l),a0    ; offset for ivar
  132.         move.l  (a7)+,d1        ; get idx
  133.         mulu    #10,d1          ; convert to offset
  134.         lea     4(a0,d1.l),a1   ; pt to element
  135.         move.l  (a7)+,d0        ; get new float ptr
  136.         lea     2(a3,d0.l),a0   ; pt to source float
  137.         move.l  (a0)+,(a1)+     ; deep copy of float data
  138.         move.l  (a0)+,(a1)+
  139.         move.w  (a0)+,(a1)+
  140. ;CODE
  141.         
  142.  
  143. :CLASS  fArray  <Super Object   10 <Indexed
  144.  
  145. ( index -- )
  146. \ ( -- x ) return the float at index
  147. :M  AT:     fltAt  ;M
  148.  
  149. ( index -- )
  150. \ ( x -- ) store a new float at index
  151. :M  TO:     fltTo   ;M
  152.  
  153. :M +TO: ( x ind -- ) dup fltAt rot f+ swap fltTo ;M
  154.  
  155. \ ( x -- ) fill all elements wih x
  156. :M  FILL:      limit 0
  157.                 DO fdup I to: self LOOP fdrop     ;M
  158.  
  159. :M  PUT: ( x x x...) limit 0 DO limit i- 1- to: self LOOP ;M
  160.  
  161. :M  GET: ( - x x x ..) limit limit: fltmem > classerr" 129
  162.     limit 0 DO i at: self LOOP ;M
  163.  
  164. \ Prints all elements
  165. :M  PRINT:  limit: self 0 DO i dup 4 .r space at: self e. cr LOOP ;M
  166.  
  167. ;CLASS
  168.  
  169. \ ( -- )  Initializes private floating point variables when present
  170. :f LocalFloat 
  171.     R 6 - dup c@ dup $ 0f and   \ number of input parameters
  172.     rot 1+ c@ over >>           \ get float mask and dump bits for input parms
  173.     rot 4 >>                    \ number of local variables
  174.     0 DO                      
  175.         dup 1 and               \ get right most bit
  176.         IF  over i + mPuts @mp  \ if on then param+i is a float
  177.             0.0 swap execute
  178.         THEN
  179.         1 >>    \ shift mask for next iteration
  180.     LOOP
  181.     2drop
  182. ;f
  183.